BBS Toolkit/BBS Toolkit.iso/doors_2/twview93.zip/MISC.INC

Text File | 1992-06-07 | 8KB | 340 lines

function str( n : integer; width : integer ) : string;
{ convert integer to string }
var
  negative : boolean;
  s : string;
begin
  if n = 0 then
    s := '0'
  else
    begin
      negative := false;
      s := '';
      if n < 0 then
        begin
          negative := true;
          n := -n;
        end;
      while n > 0 do
        begin
          s := chr( n mod 10 + ord('0') ) + s;
          n := n div 10;
        end; {while}
      if negative then
        s := '-'+s;
    end; {else}
  while length(s) < width do
    if odd( length(s) ) then
      s := s + ' '
    else
      s := ' ' + s;
  str := s;
end; {str}

function die( size : integer ) : integer;
begin
  die := random( size )  + 1;
end;

function prompt( p : string ) : boolean;
{ returns true if they say yes }
var
  ch : string;
begin
  write(p);
  readln( ch );
  prompt := ch[1] in ['Y','y'];
end; {again}

function BackupString( s : string ) : string;
{ given a filename, create an appropriate backup }
var
  i : integer;
  ext : string;
begin
  i := pos( '.', s);
  if i = 0 then
    BackupString := s + '.bak'
  else
    begin
      ext := copy( s, i + 1, 3 );
      ext[1] := upcase( ext[1] );
      ext[2] := upcase( ext[2] );
      ext[3] := upcase( ext[3] );
      if ext = 'BAK' then
        BackupString := copy( s, 1, i ) + 'bar'
      else
        BackupString := copy( s, 1, i ) + 'bak';
    end; {else}
end;

procedure MakeBackup( fname : string );
{ copy current to backup, erasing backup if needed. }
var
  f : text;
  bname : string;
begin
  bname := backupstring( fname );
  assign( f, bname );
{$I-}
  reset( f );
{$I+}
  if IOResult = 0 then
    begin
      close( f );
      erase( f );
    end;
  assign( f, fname );
  rename( f, bname );
end; {MakeBackup}

function GetNewFileName( promptstring : string; default : string ) : string;
{ Get a valid filename.  Warn if clobbering existing file. }
var
  filename : string;
  g        : text;
  errorcode: integer;
 begin
  repeat
    write( promptstring, '[', default, ']  ' );
    readln( filename );
    if filename = '' then
      if default = abort then
        halt
      else
        filename := default;
    if filename = abort then
      halt;
    assign( g, filename );
    {$I-}
    reset( g );
    {$I+}
    errorCode := ioResult;
    if errorCode = 0 then
      begin
        close( g );
        write('File already exists! ');
        if prompt('Backup? ') then
          begin
            MakeBackup( filename );
            errorcode := FileNotFound;
          end
        else if prompt('Overwrite? ') then
          errorcode := FileNotFound;
      end; {if}
  until errorcode = FileNotFound;
  GetNewFilename := filename;
end; {GetNewFilename}

function GetOldFileName( promptstring : string; default : string ) : string;
var
  filename : string;
  f        : text;
  errorcode: integer;
begin
  repeat
    write( promptstring, '[', default, ']  ' );
    readln( filename );
    if filename = '' then
      if default = abort then
        halt
      else
        filename := default;
    if filename = abort then
      halt;
    assign( f, filename );
    {$I-}
    reset( f );
    {$I+}
    errorCode := ioResult;
    if errorcode = 0 then
      close( f )
    else
      writeln('Error ', errorCode, ' opening file!');
  until errorCode = 0;
  GetOldFileName := filename;
end; {GetOldFileName}

function min( a, b : integer ) : integer;
begin
  if a > b then
    min := b
  else
    min := a;
end;

function minreal( a, b : real ) : real;
begin
  if a > b then
    minreal := b
  else
    minreal := a;
end; {minreal}

function IsWarp( from, OverTo : sector ) : boolean;
{ true if you can go from from to OverTo in one step }
var
  t : warpIndex;
begin
  IsWarp := false;
  if space.sectors[ from ].number <> UnExplored then
    for t := 1 to space.sectors[ from ].number do
      if space.sectors[ from ].data[t] = OverTo then
        IsWarp := true;
end; {IsWarp}

function GetSector : SectorIndex;
var
  s : integer;
begin
  repeat
    write('Sector? [0 to abort]  ');
    readln( s );
  until (s>=0) and (s<=MaxSector);
  GetSector := s;
end; {GetSector}

function LogToDisk( var f : text; message : string; default : string ) : boolean;
var
  filename : string;
  ch       : char;
begin
  if not prompt( message ) then
    LogToDisk := false
  else
    begin
      LogToDisk := true;
      assign( f, GetNewFilename( 'Log file? ', default) );
      rewrite( f );
    end; {else}
end; {LogToDisk}

function upcase( ch : char ) : char;
{ if letter in 'a'..'z' give upper case equivalent }
begin
  if ch in ['a'..'z'] then
    upcase := chr( ord( ch ) - ord('a') + ord('A') )
  else
    upcase := ch;
end; {upcase}

function appearanceCount ( base : sector ) : integer;
{ returns number of sectors that warp into base sector }
var
  s : sector;
  count : integer;
  i : warpIndex;
begin
  count := 0;
  for s := 1 to maxSector do
    with space.sectors[s] do
      for i := 1 to number do
        if data[i] = base then
          count := count + 1;
  appearanceCount := count;
end;

function HowFar( base : sector ) : integer;
{ return length of path leaving base sector }
var
  previous, current, NextUp : sector;
  len : integer;
begin
  previous := base;
  current := space.sectors[base].data[1];
  len := 1;
  while (space.sectors[current].number = 2) do
    begin
      NextUp := space.sectors[current].data[1];
      if NextUp = previous then
        NextUp := space.sectors[current].data[2];
      previous := current;
      current := nextUp;
      len := len + 1;
    end; {while}
  HowFar := len;
end;

procedure skip( var f : text; n : integer);
var
  ch : char;
begin
  for n := 1 to n do
    read( f, ch );
end; {skip}

function ReadNumber( var f : text) : integer;
{ Read the next number from text file f.  If there is no next number,
return 0.}
var
  number : integer;
  ch : char;
  i  : integer;
begin
  number := 0;
  if not eof( f ) then
    begin
      read( f, ch );
      while (ch <= ' ') and (not eof(f)) do begin read( f, ch ); end;
      repeat
        if ch in ['0'..'9'] then
          number := number * 10 + ord( ch ) - ord( '0' );
        if not eof( f ) then
          begin read( f, ch ); end
        else
          ch := #26;
      until (not (ch in ['0'..'9']));
      if ch = '[' then     {hit [PAUSE]^h^h^h^h^h^h^h}
        skip( f, 32 );
    end;
  ReadNumber := number;
end;

function PortNumber( s : sector ) : PortIndex;
{ return the entry into the list of ports corresponding to port s;
  return 0 if port not found. }
var
  i : portptr;
begin
  PortNumber := 0;
  if space.Ports.top > 0 then
    for i := 1 to space.Ports.top do
      if space.Ports.data[ i ].where = s then
        PortNumber := i;
end; {PortNumber}

function NoteNumber( s : sectorIndex ) : integer;
{ return the entry into the list of notes corresponding to sector s;
  return 0 if note not found. }
var
  i : 0..MaxNote;
begin
  NoteNumber := 0;
  if space.Ports.top > 0 then
    for i := 1 to space.Notes.top do
      if space.notes.data[ i ].reference = s then
        NoteNumber := i;
end; {PortNumber}

function GetPortType : stuff;
var
  pt : integer;
begin
  repeat
    writeln('Describe this port:');
    writeln(' 0 : BBB Buy all products');
    writeln(' 1 : SBB Sell Fuel Ore; buy Organics and Equipment');
    writeln(' 2 : BSB Sell Organics; buy Fuel Ore and Equipment');
    writeln(' 3 : SSB Sell Fuel Ore and Organics; buy Equipment');
    writeln(' 4 : BBS Sell Equipment; buy Fuel Ore and Organics');
    writeln(' 5 : SBS Sell Equipment and Fuel Ore; buy Organics');
    writeln(' 6 : BSS Sell Equipment and Organics; buy Fuel Ore');
    writeln(' 7 : SSS Sell all products');
    writeln(' 8 : Sell fighter, shields, holds (Class 0)');
    writeln;
    write('Port description? ');
    readln( pt );
  until (0<=pt) and (pt <= 8);
  GetPortType := pt;
end; {Get Port Type}